Attribute VB_Name = "PAK"
Option Explicit

' ------------------------------------------------------------------------------
'
'   Title:      Rob's File Packer
'   Author:     Rob Loach
'   Date:       January 06, 2003
'   Purpose:    This module is used to pack files into one single file pack and
'               easily extract them.  This does not encrypt or compress.  That
'               feature may be added in later though.
'   Copyright:  2003 Rob Loach
'
' ------------------------------------------------------------------------------




' ------------------------------------------------------------------------------
'
'   PROPERTIES, CONSTANTS, VARIABLES, AND TYPES
'
' ------------------------------------------------------------------------------
    
    'Private PAKFile As String
    ' The Header is what is put at the beginning of the PAK file.
    ' It is recommended that you leave this as is.
    Private Const Header As String = "OTPak "
    
    ' The collection of files in the PAK file.
    Public PAKFileList As New Collection
    
    
' ------------------------------------------------------------------------------
'
'   FUNCTIONS
'
' ------------------------------------------------------------------------------
    
    Public Function PAKOpen(FileName As String) As Boolean
    
        ' Opens and initiates a PAK file for editing or viewing.
        
        ' FileName  The full file path of the file you would like to open.
    
        Dim FileNumber As Long
        Dim FileListStart As Long
        Dim CurrentFileOffset As Long
        Dim CurrentFileSize As Long
        Dim CurrentFileName As String
        
        'On Error GoTo Erro
        
        ' Reset the file information
        On Error Resume Next
        For FileNumber = 1 To PAKFileList.Count
           PAKFileList.Remove (FileNumber)
        Next
        On Error GoTo 0
        
        
        'Check if is a valid PAK file
        If PAKValid(FileName) = True Then
            PAKOpen = True
            FileNumber = FreeFile
            Open FileName For Binary As FileNumber
            'Is a valid PAK file
            'Get the PAKFileList
            Get FileNumber, 7, FileListStart
            
            If FileListStart = 0 Then
                'MessageBox "Empy file!", OKOnly, Information
                Close FileNumber
                Exit Function
            Else
                'PAKFile = FileName
                'Toolbar.Buttons(4).Enabled = True
                
                'Add the FileName, CurrentOffset and CurrentSize in the ListView control
                'ListFiles.ListItems.Clear
                
                Do
                    Get FileNumber, FileListStart, CurrentFileOffset
                    FileListStart = FileListStart + 4
                    
                    Get FileNumber, FileListStart, CurrentFileSize
                    FileListStart = FileListStart + 4
                    
                    CurrentFileName = String$(255, Chr$(0))
                    Get FileNumber, FileListStart, CurrentFileName
                    CurrentFileName = Mid(CurrentFileName, 1, InStr(1, CurrentFileName, Chr$(0)) - 1)
                    FileListStart = FileListStart + Len(CurrentFileName) + 1
                    
                    ' Check to make sure it's valid again.
                    If CurrentFileName = "" Or CurrentFileOffset = 0 Or CurrentFileSize = 0 Then
                        'MessageBox "Empy file!", OKOnly, Information
                        Close FileNumber
                        Exit Function
                    End If
                
                    PAKFileList.Add CurrentFileName
                    
                Loop Until FileListStart > LOF(FileNumber)
            End If
        Else
            'Is a invalid PAK file
            PAKOpen = False
            'CommonDialog.FileName = ""
            'PAKFile = ""
            'Toolbar.Buttons(4).Enabled = False
            'MessageBox "The specified filename is not a valid file!", OKOnly, Critical
            Close FileNumber
            Exit Function
        End If
        Close FileNumber
        Exit Function
        
Erro:
        If Err = 5 Then
            PAKOpen = False
            'PAKFile = ""
            'CommonDialog.FileName = ""
            'ListFiles.ListItems.Clear
            'Toolbar.Buttons(4).Enabled = False
            'MessageBox "A error occur when trying to read the file!", OKOnly, Critical
            Close FileNumber
            Exit Function
        End If
    End Function
    
    
    Public Function PAKCreate(FileName As String) As Boolean
    
        ' Creates a new PAK file.
        
        ' FileName  The full file path of new PAK file you'd like to make.
    
        On Error GoTo Erro
        Dim FileNumber As Long
        Dim FileListStart As Long
        
        FileListStart = 0
        
        If FileExist(FileName) = True Then
            PAKCreate = False
            Exit Function
        Else
            FileNumber = FreeFile
            Open FileName For Binary As FileNumber
                Put FileNumber, 1, Header
                Put FileNumber, Len(Header) + 1, FileListStart
            Close FileNumber
        End If
        'PAKFile = FileName
        'Toolbar.Buttons(4).Enabled = True
        PAKCreate = True
        Exit Function
        
Erro:
        If Err <> 0 Then
            PAKCreate = False
            Exit Function
        End If
    End Function
    
    Public Function PAKExists(ByVal FileName As String, ByVal FilePAK As String, Optional ByVal OpenAgain As Boolean = True)
    
        ' Checks if a file inside the given PAK file exists.
    
        Dim x As Long
        
        If OpenAgain Then PAK.PAKOpen FileName
        For x = 1 To PAKFileList.Count
            If LCase$(PAKFileList.Item(x)) = LCase$(FilePAK) Then
                PAKExists = True
                Exit Function
            End If
        Next x
    End Function
    
    Public Function PAKAdd(ByVal FilePAK As String, ByVal FileADD As String, Optional ByVal NameADD As String) As Boolean
    
        ' Adds a file to the given PAK file.
        
        ' FilePAK       The PAK file's full file path.
        ' FileADD       The file you would like to add to the PAK file.
        ' NameADD       Use this if you would like to change the filename of the file once it's in the PAK file.
        '               If you don't suply NameADD then it uses the filename given in the file's path.
        
        On Error GoTo Erro
        Dim BytesADD As String
        Dim OffSetADD As Long
        Dim SizeADD As Long
        Dim FileNumberPAK As Long
        Dim FileNumberADD As Long
        Dim Position As Long
        Dim sFileList As String
        Dim FileListStart As Long
        
        ' Make the name from the path if it isn't given.
        If Len(NameADD) = 0 Then NameADD = Mid$(FileADD, Len(FileADD) - InStr(StrReverse(FileADD), "\") + 2)
        
        NameADD = NameADD & Chr$(0)
        
        If FileExist(FilePAK) = False Or FileExist(FileADD) = False Then
            PAKAdd = False
            Exit Function
        Else
            'Check if is a valid PAK file
            If PAKValid(FilePAK) = True Then
                'Is a valid PAK file
                
                FileNumberPAK = FreeFile
                Open FilePAK For Binary As FileNumberPAK
        
                
                'Get the sFileList
                
                Get FileNumberPAK, 7, FileListStart
        
                'Get the sFileList and put in the memory
                If FileListStart = 0 Then
                    FileListStart = LOF(FileNumberPAK) + 1
                    sFileList = ""
                Else
                    sFileList = String(LOF(FileNumberPAK) - FileListStart + 1, Chr$(0))
                    Get FileNumberPAK, FileListStart, sFileList
                End If
        
                OffSetADD = FileListStart
                SizeADD = FileLen(FileADD)
                    
                'Put the file inside of the PAK
                FileNumberADD = FreeFile
                
                Open FileADD For Binary As FileNumberADD
                    If LOF(FileNumberADD) > 1000000 Then
                        
                        Position = -999999
                        Do
                            Position = Position + 1000000
                            If Position + 999999 > LOF(FileNumberADD) Then
                                BytesADD = String(LOF(FileNumberADD) - Position + 1, Chr$(0))
                            Else
                                BytesADD = String(1000000, Chr$(0))
                            End If
                            Get FileNumberADD, Position, BytesADD
                            Put FileNumberPAK, FileListStart, BytesADD
                            FileListStart = FileListStart + Len(BytesADD)
                        Loop Until Position + 999999 > LOF(FileNumberADD)
                        
                    Else
                        BytesADD = String(LOF(FileNumberADD), Chr$(0))
                        Get FileNumberADD, 1, BytesADD
                        Put FileNumberPAK, FileListStart, BytesADD
                        FileListStart = FileListStart + Len(BytesADD)
                    End If
                Close FileNumberADD
                
                'Add the new file in the sFileList
                Put FileNumberPAK, 7, FileListStart
                Put FileNumberPAK, FileListStart, sFileList
                Put FileNumberPAK, FileListStart + Len(sFileList), OffSetADD
                Put FileNumberPAK, FileListStart + Len(sFileList) + 4, SizeADD
                Put FileNumberPAK, FileListStart + Len(sFileList) + 8, NameADD
                
                PAKFileList.Add FileADD
                
                Close FileNumberPAK
            Else
                PAKAdd = False
                Exit Function
            End If
        End If
        PAKAdd = True
        
        Exit Function
        
Erro:
        PAKAdd = False
        Exit Function
    End Function
    
    Public Function PAKValid(PAKFileName As String) As Boolean
    
        ' Checks to see if the given file is a valid PAK file.
        
        ' PAKFileName   The file you want to check.
    
        Dim Header2 As String
        Dim FileNumber As Long
        Header2 = String$(Len(Header), Chr$(0))
        
        If FileExist(PAKFileName) = False Then
            PAKValid = False
            Exit Function
        Else
            FileNumber = FreeFile
            Open PAKFileName For Binary As FileNumber
                Get FileNumber, 1, Header2
                If Header2 = Header Then
                    PAKValid = True
                Else
                    PAKValid = False
                End If
            Close FileNumber
        End If
    End Function
    
    Public Function PAKExtract(ByVal PAKFile As String, ByVal FileToExtract As String, Optional ByVal DestinationFile As String) As Boolean
    
        ' Extracts a file from the given PAKFile.
        
        ' PAKFile           The PAK file you would like to extract from.
        ' FileToExtract     The file you would like to extract from the PAK file.
        ' DestinationFile   The location you would like to extract the file to.
    
        Dim BytesExtract As String
        Dim offset As Long
        Dim Size As Long
        Dim Name As String
        Dim FileNumber As Long
        Dim DestinationNumber As Long
        Dim Position As Long
        Dim FileListStart As Long
        
        ' Make the destination if it isn't provided.
        If Len(DestinationFile) = 0 Then DestinationFile = Left$(PAKFile, InStrRev(PAKFile, "\") - 1) & "\" & FileToExtract
        
        If FileExist(PAKFile) = False Or FileExist(DestinationFile) = True Then
            PAKExtract = False
            Exit Function
        Else
            If PAKValid(PAKFile) = True Then
            
                FileNumber = FreeFile
                Open PAKFile For Binary As FileNumber
                    'Get the PAKFileList
                    Get FileNumber, 7, FileListStart
                
                    If FileListStart = 0 Then
                        PAKExtract = False
                        Close FileNumber
                        Exit Function
                    Else
                        
        
                        Do
                            Get FileNumber, FileListStart, offset
                            FileListStart = FileListStart + 4
                        
                            Get FileNumber, FileListStart, Size
                            FileListStart = FileListStart + 4
                        
                            Name = String$(255, Chr$(0))
                            Get FileNumber, FileListStart, Name
                            Name = Mid(Name, 1, InStr(1, Name, Chr$(0)) - 1)
                            FileListStart = FileListStart + Len(Name) + 1
                        
                            If Name = "" Or offset = 0 Or Size = 0 Then
                                PAKExtract = False
                                Close FileNumber
                                Exit Function
                            ElseIf LCase$(Name) = LCase$(FileToExtract) Then
                                DestinationNumber = FreeFile()
                                Open DestinationFile For Binary As DestinationNumber
                                    If Size > 100000 Then
                                        
                                        Position = -1000000
                                        
                                        Do
                                            
                                            Position = Position + 1000000
                                            If Position + 999999 > Size Then
                                                BytesExtract = String(Size - Position, Chr$(0))
                                            Else
                                                BytesExtract = String(1000000, Chr$(0))
                                            End If
                                            Get FileNumber, Position + offset, BytesExtract
                                            Put DestinationNumber, Position + 1, BytesExtract
                                        Loop Until Position + 999999 >= Size
                                    Else
                                        BytesExtract = String(Size, Chr$(0))
                                        Get FileNumber, offset, BytesExtract
                                        Put DestinationNumber, 1, BytesExtract
                                    End If
                                Close DestinationNumber
                                Close FileNumber
                                PAKExtract = True
                                Exit Function
                            End If
                        Loop Until FileListStart > LOF(FileNumber)
                    End If
                Close FileNumber
                PAKExtract = False
            Else
                PAKExtract = False
                Exit Function
            End If
        End If
    
    End Function

    Private Function FileExist(FileName As String) As Boolean
    
        ' Checks if any file exists.
        
        ' FileName  The full file path you would like to check.
    
        On Error GoTo Erro
        If FileLen(FileName) <> 0 Then
            FileExist = True
        Else
            FileExist = False
        End If
        Exit Function
Erro:
        If Err = 76 Or Err = 53 Then FileExist = False
    End Function
